BBS in a Box 15/BBS in a box XV-2.iso/Files II/Prog/S/SERIAL.PAS.sit/SERIAL.PAS

Pascal/Delphi Source File | 1991-01-20 | 5.0 KB | 215 lines | [TEXT/QED1]

{ Serial Demo program adapted from SerialDemo.c by Mark Y. Geschelin.}
{ This program uses the modem port to send and recieve characters.}
{ It functions as a very simple terminal emulator.  This is meant to be an}
{ example of the use of the Serial Manager, not an example of how to code}
{ a terminal emulator!!}
{ Compile this program with Runtime.lib, Interface.lib, and Serial.p}
{ Pascal port by Phil Shapiro and Mark Y. Geschelin, ) 1990 Symantec Corp.}
{  Revised:}
{        7-3-90   Myg    added handshaking and made buffer larger as well as some special processing because}
{                                 i found the default behavior really annoying during testing}

program SerialDemo (input, output);
    uses
        Serial;
    const
        EscapeChar = $1b;
        LinefeedChar = $0a;
        backspacechar = $08;
        deletechar = $7f;
        Echo = false;
        recieve_raw = false;  { set this to true to see the raw data as sent - yuk}
        transmit_raw = false; { set this to true to send the data exactly as typed -yuk}
        BufferLen = 1024;
        xonchar = char($11);
        xoffchar = char($13);
        hatchar = $5E;
    type
        BufferType = packed array[1..BufferLen] of signedbyte;
        BufferPtr = ^BufferType;
    var
        inBuf: BufferPtr;                            {our buffer}
        SerialManagerBuffer: BufferPtr;  {the buffer for the serial manager}
        flags: sershk;                                {data structure to set up handshaking}

    function AvailChar: char;                {pole for data from keyboard}
        var
            c: char;
            event: EventRecord;
            foo: boolean;
        function interpret_output (xy: signedbyte): char;
        begin
            if transmit_raw then
                interpret_output := char(xy)
            else
                case xy of
                    backspacechar:
                        interpret_output := char(deletechar);
                    linefeedchar:
                        ;
                    otherwise
                        interpret_output := char(xy);
                end;
        end;
    begin
        c := char(0);
        if getnextevent(everyevent, event) then
            if (event.what = keyDown) or (event.what = autoKey) then
                begin
                    c := interpret_output(BAND(event.message, charCodeMask));
                end;
        AvailChar := c;
    end;

    procedure CleanUp;
    begin
        RAMSDClose(sPortA);
        if inbuf <> nil then
            DisposPtr(Ptr(inbuf));
    end;

    procedure DisplayBuff (count: longint);
        var
            i: longint;
            hatflag: boolean;
        procedure interpret (x: signedbyte);
        begin
            if hatflag then
                hatflag := false
            else
                begin
                    if recieve_raw then
                        write(char(x))
                    else
                        case x of
                            linefeedchar:
                                ;
                            backspacechar:
                                ;
                            hatchar:
                                hatflag := true;
                            otherwise
                                write(char(x));
                        end;
                end;
        end;
    begin
        hatflag := false;
        for i := 1 to count do
            interpret(inbuf^[i]);
    end;

    procedure GetSerialChars (count: longint);
        var
            err: OSErr;
    begin
        err := FSRead(AinRefNum, count, Ptr(inbuf));
    end;

    function SerialCharsAvail: integer;
        var
            count: longint;
            err: OSErr;
    begin
        err := SerGetBuf(AinRefNum, count);
        SerialCharsAvail := count
    end;

    procedure SerialWrite (ch: char);
        var
            err: OSErr;
            num: longint;
            cha: signedbyte;
    begin
        num := 1;
        cha := signedbyte(ch);
        err := FSWrite(AoutRefNum, num, Ptr(ord4(@cha)))
    end;

    function SerialInit: OSErr;
        var
            err: OSErr;
            flags: sershk;
    begin
        with flags do
            begin
                fxon := byte(TRUE);
                finx := byte(TRUE);
                xon := xonchar;
                xoff := xoffchar;
            end;
        new(serialmanagerbuffer);
        new(inbuf);
        err := RAMSDOpen(sPortA);
        if err = noErr then
            begin
                err := SerReset(AinRefNum, baud:2400 + data8 + stop10 + noParity);
{make a large input buffer}
                err := err + sersetbuf(ainrefnum, ptr(serialmanagerbuffer), sizeof(buffertype));
{and even with the large input buffer set it up so it will send an xoff when the buffer is full }
{see the flags structure}
                err := err + serHshake(ainrefnum, flags);
                if err = noErr then
                    begin
                        err := SerReset(AoutRefNum, baud2400 + data8 + stop10 + noParity);
                    end
            end;
        if err <> noErr then
            RAMSDClose(sPortA);
        SerialInit := err;
    end;

    procedure Introduction;
        var
            r: Rect;
    begin
        SetRect(r, 5, 40, 475, 310);
        SetTextRect(r);
        ShowText;
        writeln('This program reads and writes to the modem port at 2400 baud.');
        writeln('It uses 8 data bits, 1 stop bits, and no parity.');
        writeln('Press the <ESC> key to exit');
    end;

    procedure Main;
        var
            err: OSErr;
            count: integer;
            ch: char;
    begin
        err := SerialInit;
        if err = noErr then
            begin
                ch := AvailChar;
                while ord(ch) <> EscapeChar do
                    begin
                        if ord(ch) <> 0 then
                            begin
                                SerialWrite(ch);
                                if echo then
                                    write(ch)
                            end;
                        count := SerialCharsAvail;
{see what happens if you comment out the serhshake and leave this code in}
{    if count > (bufferlen div 2) then}
{    begin}
{    writeln;}
{    writeln('were are getting full warning count =', count, ' if this = buflen-1 chances are we overran');}
{    end;}
                        if count <> 0 then
                            begin
                                GetSerialChars(count);
                                DisplayBuff(count)
                            end;
                        ch := AvailChar;
                    end;     {while}
            end
        else
            writeln('The serial initializations have failed, id = ', err);
    end;

begin
    Introduction;
    Main;
    CleanUp
end